Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume10/comobj.lisp/part05

Internet Message Format | 1987-07-30 | 42.8 KB

Path: uunet!rs
From: [e-mail] (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v10i079:  Common Objects, Common Loops, Common Lisp, Part05/13
Message-ID: <[e-mail]>
Date: 31 Jul 87 20:00:57 GMT
Organization: UUNET Communications Services, Arlington, VA
Lines: 1422
Approved: [e-mail]

Submitted-by: Roy D'Souza <[e-mail]>
Posting-number: Volume 10, Issue 79
Archive-name: comobj.lisp/Part05

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 5 (of 13)."
# Contents:  meth-combi.l profmacs.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'meth-combi.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'meth-combi.l'\"
else
echo shar: Extracting \"'meth-combi.l'\" \(19923 characters\)
sed "s/^X//" >'meth-combi.l' <<'END_OF_FILE'
X;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; User-defined method combination.  A first try.
X;;;
X;;; For compatibility with New Flavors, the following functions macros and
X;;; variables have the same meaning.
X;;;   define-simple-method-combination
X;;;   define-method-combination
X;;;   call-component-method
X;;;   call-component-methods
X;;;   *combined-method-arguments*
X;;;   *combined-method-apply*
X;;;
X;;; In define-method-combination the arguments have the following meanings:
X;;;
X;;;   name             the name of this method combination type (symbol)
X;;;   parameters       like a defmacro lambda list, it is matched with
X;;;                    the value specified by the :method-combination
X;;;                    option to make-specializable
X;;;   method-patterns  a list of method-patterns specifications that are
X;;;                    used to select some subset of the methods defined
X;;;                    on the discriminator.  Each method pattern specifies
X;;;                    a variable which is bound to a list of the methods
X;;;                    it selects.
X;;;   body             forms evaluated with the variables specified by
X;;;                    the method patterns bound to produce the body of
X;;;                    the combined method.  (see call-component-methods).
X;;;
X;;;  Body can be preceded by any number of options which take the form:
X;;;    (<option-name> . <option-args>)
X;;;
X;;;  Currently, the defined options are:
X;;;
X;;;   :causes-combination-predicate
X;;;       The only argument, should be a function of one argument.  It
X;;;       will be called on a method (of the discriminator) and should
X;;;       return T if that method causes the discriminator to combine
X;;;       its methods.
X;;;
X;;; A method-patterns looks like:
X;;;
X;;;   (<var> <printer> <filter> <order> <pattern-1> <pattern-2> ..)
X;;;
X;;;      <var>      is the variable to which the selected methods
X;;;                 are bound
X;;;      <printer>  is ignored
X;;;      <filter>   one of :every, :first, :last or :remove-duplicates
X;;;      <order>    :most-specific-first or :most-specific-last
X;;;
X;;;      Methods matching any of the patterns are selected.  The patterns
X;;;      are matched against the method-combination-options of the method
X;;;      as specified in the defmeth.
X;;;
X
X(in-package 'pcl)
X
X;;;
X;;; The method combination type of a particular method combination is stored
X;;; as a symbol (the name of the method-combination) in the discriminator (in
X;;; the method-combination-type slot).  Information about that particular
X;;; method-combination-type is stored on the property list of the type symbol
X;;;
X(defun get-method-combination-info (type &optional no-error-p)
X  (or (get type 'method-combination)
X      (if no-error-p () (error "No method combination named ~S." type))))
X
X(defun set-method-combination-info (type combiner predicate)
X  (setf (get type 'method-combination) (list type combiner predicate)))
X
X(defmeth method-combiner ((discriminator method-combination-mixin))
X  (cadr (get-method-combination-info
X          (method-combination-type discriminator))))
X
X(defmeth method-causes-combination-predicate
X         ((discriminator method-combination-mixin))
X  (caddr (get-method-combination-info
X           (method-combination-type discriminator))))
X
X
X
X
X  ;;
X;;;;;; COMBINED-METHOD class
X  ;;
X
X(ndefstruct (combined-method (:class class)
X                             (:include (method)))
X  (deactivated-methods ()))
X
X(defmeth automatically-defined-p ((m combined-method)) (ignore m) t)
X
X(defmeth method-options ((m combined-method)) (ignore m) '(:combined))
X
X(defmeth method-causes-combination-p ((m combined-method)) (ignore m) nil)
X
X(defmacro define-simple-method-combination (name operator
X                                            &optional single-arg-is-value
X                                                      (pretty-name
X                                                        (string-downcase
X                                                          name)))
X  `(define-method-combination ,name
X                              (&optional (order :most-specific-first))
X             ((methods ,pretty-name :every order () (,name) :default))
X     `(call-component-methods ,methods
X                              :operator ,',operator
X                              :single-arg-is-value ,',single-arg-is-value)))
X
X(defmacro define-method-combination (name parameters method-patterns
X                                     &body body)
X  (check-type parameters list)
X  (check-type method-patterns (and list (not null)))
X  (make-method-combination name parameters method-patterns body))
X
X
X(defvar *combined-method-arguments*)
X(defvar *combined-method-apply*)
X(defvar *combined-method-template*)
X
X;;;
X;;; Generate a form that calls a single method.
X;;; With no keyword arguments, uses the value of *combined-methods-arguments*
X;;; as the arguments to the call;
X;;; With :ARGLIST, uses that instead;
X;;; With :ARGLIST and :APPLY T, uses APPLY instead of FUNCALL
X;;; With just :APPLY, it is the single argument to apply to.
X;;;
X;;; When called with *combined-method-template* bound, generates calls to
X;;; the value of variables gotten from *combined-method-template* instead
X;;; of to the actual methods themselves.  This is used to build templates
X;;; for combined methods.
X;;;
X(defmacro call-component-method
X          (method &key (apply nil apply-p)
X                       (arglist
X                         (if apply-p
X                             (prog1 (list apply) (setq apply t))
X                             (prog1 *combined-method-arguments*
X                                    (setq apply *combined-method-apply*)))))
X  (call-component-method-internal method apply arglist))
X
X(defmacro call-component-methods (methods &key (operator 'progn)
X                                               (single-arg-is-value nil))
X  (call-component-methods-internal methods operator single-arg-is-value))
X
X(defmeth call-component-method-internal
X         (method &optional (apply *combined-method-apply*)
X                           (arglist *combined-method-arguments*))
X  (when method
X    `(,(if apply 'apply 'funcall)
X      ,(if (boundp '*combined-method-template*)
X       (let ((gensym (cdr (assq method *combined-method-template*))))
X         (if gensym
X         `(the function ,gensym)
X         (error "*combined-method-template* out of sync??")))
X       `',(method-function method))
X      ,@arglist)))
X
X(defmeth call-component-methods-internal (methods
X                      operator single-arg-is-value)
X  (when methods
X    (if (and single-arg-is-value (null (cdr methods)))
X    (call-component-method-internal (car methods))
X    `(,operator
X      ,@(iterate ((method in methods))
X          (collect (call-component-method-internal method)))))))
X
X(defmeth call-component-method-equal (discriminator call-1 call-2)
X  ;; If the options are the same (the part that the macros control the
X  ;; processing of); and the individual calls are the same the part the
X  ;; methods themselves control the processing of.
X  (and (equal (cddr call-1) (cddr call-2))
X       (if (eq (car call-1) 'call-component-method)
X       (cond ((null (cadr call-1)) (null (cadr call-2)))
X         ((null (cadr call-2)) (null (cadr call-1)))
X         (t
X          (call-component-method-equal-internal
X            discriminator (cadr call-1) (cadr call-2))))
X           (iterate ((meth-1 on (cadr call-1))
X                     (meth-2 on (cadr call-2)))
X         (when (or (and (cdr meth-1) (null (cdr meth-2)))
X               (and (cdr meth-2) (null (cdr meth-1)))
X               (null (call-component-method-equal-internal
X                   discriminator (car meth-1) (car meth-2))))
X           (return nil))))))
X
X(defmeth call-component-method-equal-internal (discriminator meth-1 meth-2)
X  (ignore discriminator meth-1 meth-2)
X  t)
X
X
X
X(defvar *method-combination-filters*
X        '(:every :first :last :remove-duplicates))
X
X(defvar *method-combination-orders*
X        '(:most-specific-first :most-specific-last))
X
X(defun make-method-combination (name parameters method-patterns body)
X  (let ((causes-combination-predicate 'true)
X        (combiner (make-symbol (string-append name " Method Combiner"))))
X    ;; Error check and canonicalize the arguments.
X    (unless (symbolp name)
X      (error "The name of a method combination type must be a symbol, but ~S~
X            was specified."
X             name))
X    ;; Check the various sub-parts of each method-patterns.  Canonicalize
X    ;; each method-pattern by adding the () pattern to it if it has no
X    ;; other patterns.
X    (iterate ((method-patterns-loc on method-patterns))
X      (destructuring-bind (var printer filter order . patterns)
X                          (car method-patterns-loc)
X        (check-symbol-variability var "bind (in a method-patterns)")
X        (or (null (keywordp filter))
X            (memq filter *method-combination-filters*)
X            (error "A method-patterns filter must be one of: ~S~%not ~S."
X                   *method-combination-filters* filter))
X        (or (null (keywordp order))
X            (memq order *method-combination-orders*)
X            (error "A method-patterns order must be one of: ~S~%not ~S."
X                   *method-combination-orders* filter))
X        (if (null patterns)
X            (setf (car method-patterns-loc)
X                  (append (car method-patterns-loc) (list nil)))
X            (iterate ((pattern in patterns))
X              (or (listp pattern)
X                  (eq pattern ':default)
X                  (error "A method-pattern must be a list.~%~
X                         In the method-patterns ~S, ~S is an invalid pattern."
X                         (car method-patterns-loc) pattern))))))
X    (iterate ()
X      (while (and body (listp (car body))))
X      (case (caar body)
X        (:causes-combination-predicate
X          (setq causes-combination-predicate (cadr (pop body))))
X        (otherwise (return))))
X
X    `(progn
X       ,(make-combiner-definer
X          combiner name parameters method-patterns body)
X       (setf (get ',name 'combined-method-templates) ())
X       (set-method-combination-info ',name
X                                    ',combiner
X                                    ',causes-combination-predicate))))
X
X(defun make-combiner-definer
X       (combiner name parameters method-patterns body)
X  (ignore name)
X  `(defun ,combiner (.discriminator. .methods. .params.)
X     .discriminator.
X     (apply
X       #'(lambda ,parameters
X           (let ,(iterate (((var) in method-patterns)) (collect `(,var nil)))
X             (do ((.method. (pop .methods.) (pop .methods.)))
X                 ((null .method.))
X               (cond
X                 ,@(iterate (((var nil fil ord . pats) in method-patterns))
X                     (collect
X               `((and ,(ecase fil
X                 (:first
X                   `(if (eq ,ord :most-specific-first)
X                    (null ,var)
X                    't))
X                 (:last
X                   `(if (eq ,ord :most-specific-first)
X                    t
X                    (null ,var)))
X                 (:every
X                   't))
X                  (method-matches-patterns-p .method. ',pats))
X                         (push .method. ,var))))))
X         ,@(iterate (((var nil fil ord) in method-patterns))
X         (cond ((memq fil '(:first :last))
X            (collect `(setq ,var (car ,var))))
X               ((eq ord ':most-specific-first)
X            (collect `(setq ,var (nreverse ,var))))))
X             ,@body))
X       .params.)))
X
X
X(defmeth method-matches-patterns-p (method patterns)
X  (iterate ((pattern in patterns))
X    (when (method-matches-pattern-p method pattern)
X      (return t))))
X
X(defmeth method-matches-pattern-p (method pattern)
X  (iterate ((pats = pattern (cdr pats))
X            (opts = (method-options method) (cdr opts)))
X    (if (symbolp pats)
X        ;; Special case this because it means we have to blow out of
X        ;; iterate.  Should iterate should know about dotted lists.
X        (return (or (eq pats '*) (eq pats opts)))
X        (unless (or (eq (car pats) '*)
X                    (equal (car pats) (car opts)))
X          (return nil)))
X    (finally (return t))))
X
X(defun patterns-keywords (patterns)
X  (let ((keywords ()))
X    (iterate ((pattern in patterns))
X      (iterate ((elem in pattern))
X        (when (keywordp elem) (push elem keywords))))
X    keywords))
X
X(defun check-symbol-variability (symbol verb)
X  (cond ((not (symbolp symbol))
X         (error "Attempt to ~A ~S which is not a symbol" verb symbol))
X        ((or (null symbol) (eq symbol 't))
X         (error "Attempt to ~A ~S" verb symbol))
X        ((eq (symbol-package symbol) (find-package 'keyword))
X         (error "Attempt to ~A ~S, which is a keyword" verb symbol))
X        ((constantp symbol)
X         (error "Attempt to ~A ~S, which is a constant" verb symbol))))
X
X(defun cpl-filter-= (cpl1 cpl2 discriminator)
X  (macrolet ((has-method-on-discriminator-p (class)
X           `(memq discriminator (class-direct-discriminators ,class))))
X    (prog ()
X       restart
X          (cond ((null cpl1)
X         (if (null cpl2)
X             (return t)
X             (return nil)))
X                ((null cpl2)
X                 (return nil)))
X          (unless (has-method-on-discriminator-p (car cpl1))
X            (pop cpl1)
X            (go restart))
X          (unless (has-method-on-discriminator-p (car cpl2))
X            (pop cpl2)
X            (go restart))
X          (if (neq (pop cpl1) (pop cpl2))
X              (return nil)
X          (go restart)))))
X
X
X;;;   class-discriminators-which-combine-methods
X;;;   discriminator-methods-combine-p
X
X(defmeth combine-methods ((class class) &optional discriminators)
X  (let ((cpl (class-class-precedence-list class))
X        (method nil)
X        (method-cpl nil)
X        (combined-method nil))
X
X    (iterate ((disc in discriminators))
X      (setq method (lookup-method disc class)
X        method-cpl (and method
X                (not (combined-method-p method))
X                (class-class-precedence-list
X                  (car (method-type-specifiers method)))))
X      (unless (cpl-filter-= cpl method-cpl disc)
X    (dolist (other-method (discriminator-methods disc))
X      (when (and (combined-method-p other-method)
X             (eq (car (method-type-specifiers other-method))
X             class))
X        (remove-method disc other-method)))
X    (multiple-value-bind (arguments apply-p body)
X        (combine-methods-internal class disc cpl)
X      (setq combined-method
X        (make 'combined-method
X              :function (compile-combined-method
X                  disc arguments apply-p body)
X              :arglist arguments
X              :type-specifiers (cons class
X                         (cdr (method-type-specifiers
X                            method)))))
X      (add-method disc combined-method nil))))))
X
X(defmeth combine-methods-internal (class discriminator cpl)
X  (ignore class)
X  (let ((methods (iterate ((c in cpl))
X                   (join
X             (iterate ((m in (discriminator-methods discriminator)))
X               (when (and (eq (car (method-type-specifiers m)) c)
X                  (not (combined-method-p m)))
X             (collect m)))))))
X    (multiple-value-bind (required restp)
X        (compute-discriminating-function-arglist-info discriminator)
X      (let ((*combined-method-arguments*
X              (make-discriminating-function-arglist required restp))
X            (*combined-method-apply* restp))
X        (values *combined-method-arguments*
X                *combined-method-apply*
X                (funcall (method-combiner discriminator)
X                         discriminator methods ()))))))
X
X
X  ;;
X;;;;;; COMPILE-COMBINED-METHOD
X  ;;
X
X(defmeth compile-combined-method ((discriminator method-combination-mixin)
X                                  *combined-method-arguments*
X                                  *combined-method-apply*
X                                  body)
X  (multiple-value-bind (constructor methods-called)
X      (compile-combined-method-internal discriminator body)
X    (apply constructor (mapcar #'method-function methods-called))))
X
X(defmeth compile-combined-method-internal (discriminator body)
X  (let* ((combination-type (method-combination-type discriminator))
X         (templates (get combination-type 'combined-method-templates))
X         (methods-called ())
X         (walked-body
X           (walk-form body
X             :walk-function
X             #'(lambda (form context &aux temp)
X                 (ignore context)
X                 (values form
X                         (and (eq context 'eval)
X                              (listp form)
X                              (setq temp (car form))
X                              (cond ((eq temp 'call-component-method)
X                                     (push (cadr form) methods-called))
X                                    ((eq temp 'call-component-methods)
X                                     (setq methods-called
X                                           (append (cadr form)
X                                                   methods-called))))))))))
X    (setq methods-called (remove nil methods-called))
X    (iterate ((entry in templates))
X      (when (combined-method-equal discriminator (car entry) walked-body)
X        (return (values (cdr entry) methods-called)))
X      (finally
X        (let* ((*combined-method-template*
X                 (iterate ((method in methods-called))
X                   (collect (cons method (gensym)))))
X               (new-constructor
X                 (compile ()
X                          `(lambda
X                             ,(mapcar #'cdr *combined-method-template*)
X                             #'(lambda ,*combined-method-arguments*
X                                 ,(walk-form walked-body))))))
X          (push (cons walked-body new-constructor)
X                (get combination-type 'combined-method-templates))
X          (return (values new-constructor methods-called)))))))
X
X(defmeth combined-method-equal (discriminator comb-meth-1 comb-meth-2)
X  (cond ((atom comb-meth-1) (eq comb-meth-1 comb-meth-2))
X        ((memq (car comb-meth-1)
X               '(call-component-method call-component-methods))
X         (and (eq (car comb-meth-1) (car comb-meth-2))
X              (call-component-method-equal
X                discriminator comb-meth-1 comb-meth-2)))
X        (t
X         (and (combined-method-equal
X                discriminator (car comb-meth-1) (car comb-meth-2))
X              (combined-method-equal
X                discriminator (cdr comb-meth-1) (cdr comb-meth-2))))))
X
X
X
X(defmeth discriminator-changed ((discriminator method-combination-mixin)
X                (method combined-method)
X                added-p)
X  (ignore discriminator method added-p))
X
X(defmeth discriminator-changed ((discriminator method-combination-mixin)
X                method
X                added-p)
X  (when (methods-combine-p discriminator)
X    (let ((class (car (method-type-specifiers method))))
X      (when (classp class)
X    (labels ((walk-tree (class)
X           (combine-methods class (list discriminator))
X           (dolist (subclass (class-direct-subclasses class))
X             (walk-tree subclass))))
X      (walk-tree class)))))
X  (run-super))
X
X
END_OF_FILE
if test 19923 -ne `wc -c <'meth-combi.l'`; then
    echo shar: \"'meth-combi.l'\" unpacked with wrong size!
fi
# end of 'meth-combi.l'
fi
if test -f 'profmacs.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'profmacs.l'\"
else
echo shar: Extracting \"'profmacs.l'\" \(20279 characters\)
sed "s/^X//" >'profmacs.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File:         profmacs.l
X; SCCS:         %A% %G% %U%
X; Description:  Macros For Profiling
X; Author:       James Kempf, HP/DCC
X; Created:      7-Feb-87
X; Modified:     25-Feb-87 09:06:08 (James Kempf)
X; Language:     Lisp
X; Package:      TEST
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(in-package 'test)
X(use-package 'lisp)
X
X;;Need COOL
X
X(require "co")
X(use-package 'co)
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;     System Dependent Customizations
X;
X;  Some systems will have special, hardware or software dependent profiling
X;  packages. If your system has one, put it in here. Otherwise, the default
X;  timing functions from CLtL will be used. In addition, the system dependent
X;  function for garbage collection should be inserted, if your system
X;  requires garbage collection. Otherwise, no garbage collection will be done.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;warn-garbage-collect-Warn that no garbage collection function is in use.
X
X(defun warn-garbage-collect ()
X  (warn
X    "~&********  Profiling Measurments Could Be Interrupted By Garbage Collection *******"
X  )
X) ;warn-garbage-collect
X
X;;*clock-increment-in-milliseconds*-Increment of the clock
X
X(defvar *clock-increment-in-milliseconds* 0)
X
X;;Use the 10 microsecond clock
X
X#+HP
X(eval-when (load eval)
X  (require "measure")
X  (setf (symbol-function 'get-time) (symbol-function measure:time10usec))
X  (setf *clock-increment-in-milliseconds* 0.01)
X  (setf (symbol-function 'do-garbage-collect) (symbol-function 'system:gc))
X
X)
X
X;;Default is to just use the functions from Steele
X
X#-HP
X(eval-when (load eval)
X  (setf (symbol-function 'get-time) (symbol-function 'get-internal-real-time))
X  (setf *clock-increment-in-milliseconds*
X    (* (float (/ 1.0 internal-time-units-per-second)) 1000.0)
X  )
X  (setf (symbol-function 'do-garbage-collect) (symbol-function 'warn-garbage-collect))
X
X)
X
X;;Switch for Class Definition Syntax
X
X(defvar *define-type-switch* T)
X
X;;Vector containing names of types with zero, one, two, and
X;;  three instance variables.
X
X(defvar *iv-defined-types* (make-array '(4 4) :initial-element NIL))
X
X;;Lists of results
X
X;;For type definition (iterations ivs parents time)
X
X(defvar *define-type-results* NIL)
X
X;;For instance creation (interations ivs parents time)
X
X(defvar *creation-results* NIL)
X
X;;For method definition (iterations preexisting time)
X
X(defvar *define-method-results* NIL)
X
X;;For messaging (iterations functions time)
X
X(defvar *messaging-results* NIL)
X
X;;For inherited messaging (iterations parents time)
X
X(defvar *inherited-messaging-results* NIL)
X
X;;These variables and macros are used for inserting the result of
X;;  macroexpantion times into the calculations
X
X(defvar *macro-start-clock* 0)
X(defvar *macro-end-clock* 0)
X(defvar *macro-total-time* 0)
X
X(defmacro macro-start-clock ()
X
X  (setf *macro-start-clock* (get-time))
X  NIL
X)
X
X(defmacro macro-end-clock ()
X
X  (setf *macro-end-clock* (get-time))
X  (setf *macro-total-time* (- *macro-end-clock* *macro-start-clock*))
X  (setf *macro-end-clock* 0)
X  (setf *macro-start-clock* 0)
X
X  NIL
X)
X
X(defmacro macro-insert-sum ()
X
X  (let
X    (
X     (returned-sum *macro-total-time*)
X    )
X
X    (setf *macro-total-time* 0)
X    returned-sum
X )
X
X)
X
X;;do-type-definition-Profile Type or Class Definition
X
X(defmacro do-type-definition (record variables parents)
X
X  (let
X    (
X      (iv-names NIL)
X      (code NIL)
X      (tname NIL)
X      (pnames NIL)
X    )
X
X    ;;Construct a new function symbol for this test
X
X    (push (gensym) *function-symbols*)
X
X    ;;Generate a list of instance variable names
X
X    (dotimes (i variables )
X      (setf iv-names
X        (list*
X          (if *define-type-switch*
X            `(:var ,(gentemp))
X            (gentemp)
X          )
X          iv-names
X        )
X      )
X    )
X
X    ;;Generate list of parent names
X
X    (dotimes (i parents)
X      (setf pnames
X        (list*
X          (if *define-type-switch*
X            `(:inherit-from ,(nth i (aref *iv-defined-types* 0 0)))
X             (nth i (aref *iv-defined-types* 0 0))
X          )
X          pnames
X        )
X      )
X    )
X
X    ;;Generate code for type definition
X
X    (dotimes (i 20)
X
X      ;;Generate the name for this type and
X      ;;  push onto the appropriate list
X
X      (setf tname (gentemp))
X
X      (setf (aref *iv-defined-types* parents variables)
X            (push tname (aref *iv-defined-types* parents variables))
X      )
X
X      ;;Generate the type code
X
X      (push
X        (if *define-type-switch*
X          `(define-type ,tname
X             ,@iv-names
X             ,@pnames
X           )
X           `(ndefstruct
X             (,tname
X               (:class class)
X           ,pnames
X             )
X             ,@iv-names
X           )
X        ) ;if
X
X        code
X
X      ) ;push
X
X    )
X
X    ;;Return code, inserting prolog and cache heating
X
X  `(defun ,(first *function-symbols*) ()
X    (let
X       (
X         (after 0)
X         (before 0)
X         (sum 0)
X       )
X
X       (tagbody
X       again
X
X         (do-garbage-collect)
X
X         ,(if *define-type-switch*
X           `(define-type ,(gentemp)
X             ,@iv-names
X             ,@pnames
X            )
X            `(ndefstruct
X              (,(gentemp)
X               (:class class)
X           ,pnames
X             )
X             ,@iv-names
X           )
X         ) ;if
X
X         (setf before (get-time))
X         (macro-start-clock)
X         ,@code
X         (macro-end-clock)
X         (setf after (get-time))
X
X         (setf sum (macro-insert-sum))
X
X
X         (if (< (the integer after) (the integer before))
X           (go again)
X         )
X       )
X
X       (if ,record
X         (push (list 20 ,variables ,parents (- after before) sum) *define-type-results*)
X       )
X
X      )
X
X    )
X
X   ) ;let
X
X) ;do-type-definition
X
X(setf (symbol-function 'do-type-definition-macro) (macro-function 'do-type-definition))
X(compile 'do-type-definition-macro)
X(setf (macro-function 'do-type-definition) (symbol-function 'do-type-definition-macro))
X
X;;do-instance-creation-Create instances of types as above
X
X(defmacro do-instance-creation (record ivs parents)
X
X  (let
X    (
X      (code NIL)
X    )
X
X    ;;Generate a new function symbol
X
X    (push (gensym) *function-symbols*)
X
X    ;;Generate code to create
X
X    (dotimes (i 20)
X
X      (push
X        `(make-instance ',(nth i (aref *iv-defined-types* parents ivs)))
X        code
X      )
X
X    ) ;dotimes
X
X    ;;Return code, inserting prolog and cache heating
X
X  `(defun ,(first *function-symbols*) ()
X    (let
X       (
X         (after 0)
X         (before 0)
X       )
X
X       (tagbody
X       again
X
X         (do-garbage-collect)
X
X         (make-instance ',(nth 1 (aref *iv-defined-types* parents ivs)))
X
X          (setf before (get-time))
X          ,@code
X          (setf after (get-time))
X
X      (if (< (the integer after) (the integer before))
X            (go again)
X          )
X        )
X
X        (if ,record
X          (push (list 20 ,ivs ,parents (- after before)) *creation-results*)
X        )
X
X      )
X    )
X
X  ) ;let
X
X) ;do-instance-creation
X
X(setf (symbol-function 'do-instance-creation-macro) (macro-function 'do-instance-creation))
X(compile 'do-instance-creation-macro)
X(setf (macro-function 'do-instance-creation) (symbol-function 'do-instance-creation-macro))
X
X;;switch-define-types-Define types depending on switch
X
X(defmacro switch-define-types ( parent &rest t-list)
X
X  (let
X    (
X      (code NIL)
X    )
X
X    (dolist (ty t-list)
X      (push
X        (if *define-type-switch*
X          `(define-type ,ty ,@(if parent `((:inherit-from ,parent)) NIL))
X          `(ndefstruct (,ty (:class class) ,@(if parent `((:include (,parent))) `() ) )  )
X        )
X        code
X      )
X    )
X
X    `(progn
X       ,@code
X    )
X
X  )
X) ;switch-define-types
X
X;;switch-define-method-Define method depending on switch
X
X(defmacro switch-define-method (name)
X
X  (if *define-type-switch*
X    `(define-method (,name ,(intern (symbol-name name) (find-package 'keyword)) ) () )
X    `(defmeth ,(intern (symbol-name name) co::*keyword-standin-package*)
X       ((.inner-self. ,name))
X     )
X  )
X
X) ;switch-define-method
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Define Types For Method Definition Tests and Make Instances
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;For testing method definition and invocation with varying methods on
X;;  discriminator
X
X(funcall
X  (compile ()
X    `(lambda () (switch-define-types NIL temp0 temp1 temp2 temp3 temp4))
X  )
X)
X
X(setf temp0 (make-instance 'temp0))
X(setf temp1 (make-instance 'temp1))
X(setf temp2 (make-instance 'temp2))
X(setf temp3 (make-instance 'temp3))
X(setf temp4 (make-instance 'temp4))
X
X;;For testing method invocation of inherited methods
X
X(funcall
X  (compile ()
X    `(lambda () (switch-define-types NIL g3f))
X  )
X)
X
X(funcall
X  (compile ()
X    `(lambda () (switch-define-method g3f))
X  )
X)
X
X(funcall
X  (compile ()
X    `(lambda () (switch-define-types g3f g2f))
X  )
X)
X
X(funcall
X  (compile ()
X    `(lambda () (switch-define-method g2f))
X  )
X)
X
X(funcall
X  (compile ()
X    `(lambda () (switch-define-types g2f g1f))
X  )
X)
X
X(funcall
X  (compile ()
X    `(lambda () (switch-define-method g1f))
X  )
X)
X
X(funcall
X  (compile ()
X    `(lambda () (switch-define-types g1f g0f))
X  )
X)
X
X(funcall
X  (compile ()
X    `(lambda () (switch-define-method g0f))
X  )
X)
X
X;;Make an instance of g0f
X
X(setf g0f (make-instance 'g0f))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;Method symbol List
X
X(defvar *list-of-method-symbols* NIL)
X
X;;do-method-definition-Do the method definition
X
X(defmacro do-method-definition (record  predefined fortype)
X
X  (let
X    (
X      (code NIL)
X    )
X
X    ;;Generate a new function symbol
X
X    (push (gensym) *function-symbols*)
X
X    ;;Generate method symbols if necessary
X
X    (if (not *list-of-method-symbols*)
X
X      (dotimes (i 20)
X        (push (intern (format NIL "T~D" i) (find-package :keyword))
X          *list-of-method-symbols*
X        )
X      )
X    ) ;if
X
X    ;;Generate code for method definition
X
X    (dolist (l *list-of-method-symbols*)
X
X      (push
X        (if *define-type-switch*
X          `(define-method (,fortype ,l) ()  )
X          `(defmeth ,(intern (symbol-name l) co::*keyword-standin-package*)
X             ((.inner-self. ,fortype))
X           )
X         )
X         code
X      )
X
X    )
X
X    ;;Return code, inserting prolog and cache heating
X
X  `(defun ,(first *function-symbols*) ()
X    (let
X       (
X         (after 0)
X         (before 0)
X         (sum 0)
X       )
X
X       (tagbody
X       again
X         (do-garbage-collect)
X
X         ,(if *define-type-switch*
X           `(define-method (,fortype ,(gentemp)) ()  )
X           `(defmeth ,(gentemp) ((.inner-self. ,fortype)) )
X         )
X
X         (setf before (get-time))
X         (macro-start-clock)
X         ,@code
X     (macro-end-clock)
X         (setf after (get-time))
X
X         (setf sum (macro-insert-sum))
X
X         (if (< (the integer after) (the integer before))
X           (go again)
X         )
X       )
X
X       (if ,record
X         (push (list 20 ,predefined (- after before) sum) *define-method-results*)
X       )
X
X      )
X
X    )
X
X  ) ;let
X
X) ;do-method-definition
X
X(setf (symbol-function 'do-method-definition-macro) (macro-function 'do-method-definition))
X(compile 'do-method-definition-macro)
X(setf (macro-function 'do-method-definition) (symbol-function 'do-method-definition-macro))
X
X;;do-messaging-Messaging macro code construction
X
X(defmacro do-messaging (record predefined &rest type-list)
X
X  (let
X    (
X      (code NIL)
X    )
X
X    ;;Generate a new function symbol
X
X    (push (gensym) *function-symbols*)
X
X    ;;Push on 20 messagings
X
X    (dotimes (i 20)
X
X      ;;Message for each type
X
X      (dolist (ty type-list)
X
X         (push
X           (if *define-type-switch*
X             `(=> ,ty ,(first *list-of-method-symbols*))
X             `(,(intern
X                (symbol-name (first *list-of-method-symbols*))
X                co::*keyword-standin-package*
X               )
X               ,ty
X              )
X            )
X            code
X
X         ) ;push
X
X      ) ;dolist
X
X    ) ;dotimes
X
X    ;;Return code, inserting prolog and hardware cache
X    ;;  heating to another message.
X
X  `(defun ,(first *function-symbols*) ()
X    (let
X       (
X         (after 0)
X         (before 0)
X         (sum 0)
X       )
X
X       (tagbody
X       again
X
X         (do-garbage-collect)
X
X         ,(if *define-type-switch*
X           `(=> ,(first type-list) ,(second *list-of-method-symbols*))
X           `(,(intern
X              (symbol-name (second *list-of-method-symbols*))
X              co::*keyword-standin-package*
X             )
X             ,(first type-list)
X            )
X          )
X
X
X         (setf before (get-time))
X         (macro-start-clock)
X         ,@code
X         (macro-end-clock)
X         (setf after (get-time))
X
X         (setf sum (macro-insert-sum))
X
X         (if (< (the integer after) (the integer before))
X           (go again)
X         )
X       )
X
X       (if ,record
X          (push (list (* 20 ,(length type-list))
X              ,predefined
X                  (- after before)
X                      sum
X                 )
X                 *messaging-results*
X          )
X       )
X
X      )
X
X    )
X
X  ) ;let
X
X) ;do-messaging
X
X(setf (symbol-function 'do-messaging-macro) (macro-function 'do-messaging))
X(compile 'do-messaging-macro)
X(setf (macro-function 'do-messaging) (symbol-function 'do-messaging-macro))
X
X;;do-inherited-messaging-Generate code for profiling inherited messaging
X
X(defmacro do-inherited-messaging (record level method)
X
X  (let
X    (
X      (code NIL)
X    )
X
X    ;;Generate a new function symbol
X
X    (push (gensym) *function-symbols*)
X
X    ;;Push on 20 messagings
X
X    (dotimes (i 20)
X
X      (push
X        (if *define-type-switch*
X          `(=> g0f ,(intern (symbol-name method) (find-package 'keyword)))
X          `(,(intern
X               (symbol-name method)
X               co::*keyword-standin-package*
X             )
X             g0f
X          )
X        )
X        code
X
X      ) ;push
X
X    ) ;dotimes
X
X    ;;Return code, inserting prolog and hardware cache
X    ;;  heating to another message.
X
X  `(defun ,(first *function-symbols*) ()
X    (let
X       (
X         (after 0)
X         (before 0)
X         (sum 0)
X       )
X
X       (tagbody
X       again
X
X         (do-garbage-collect)
X
X         ,(if *define-type-switch*
X           `(=> g0f ,(intern (symbol-name method) (find-package 'keyword)))
X           `(,(intern
X              (symbol-name method)
X              co::*keyword-standin-package*
X             )
X             g0f
X            )
X          )
X
X
X         (setf before (get-time))
X         (macro-start-clock)
X          ,@code
X         (macro-end-clock)
X         (setf after (get-time))
X
X         (setf sum (macro-insert-sum))
X
X         (if (< (the integer after) (the integer before))
X           (go again)
X         )
X       )
X
X       (if ,record
X         (push (list 20 ,level (- after before) sum) *inherited-messaging-results*)
X       )
X
X      )
X
X    )
X
X  ) ;let
X
X) ;do-inherited-messaging
X
X(setf (symbol-function 'do-inherited-messaging-macro) (macro-function 'do-inherited-messaging))
X(compile 'do-inherited-messaging-macro)
X(setf (macro-function 'do-inherited-messaging) (symbol-function 'do-inherited-messaging-macro))
X
X;;print-results-Print the results to the file
X
X(defun print-results (filename fromwho)
X
X  (with-open-file
X    (istream filename :direction :output
X              :if-exists :append
X              :if-does-not-exist :create
X    )
X
X    (format istream "~%~%~A~%~%" fromwho)
X    (format istream "~%~%Times are in msec. Clock increment:~F~%~%" *clock-increment-in-milliseconds*)
X
X
X
X    (format istream "~1,8@T~1,8@T~1,8@TMacroexpand Times~%~%")
X    (format istream
X            "Operation~1,8@TSlots~1,8@TParents~1,8@TIterations~1,8@TTotal Time~1,8@TTime per Call~%~%"
X    )
X    (dolist (l (reverse *define-type-results*))
X      (format istream
X              "Define Type~1,8@T~D~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X              (second l)
X              (third l)
X              (first l)
X              (* (fifth l) *clock-increment-in-milliseconds*)
X              (* (float (/ (fifth l) (first l))) *clock-increment-in-milliseconds*)
X       )
X    )
X    (format istream
X            "~%~%Operation~1,8@TIterations~1,8@TFunctions~1,8@TTotal Time~1,8@TTime per Call~%~%"
X    )
X    (dolist (l (reverse *define-method-results*))
X      (format istream
X              "Define Operation~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X              (first l)
X              (second l)
X              (* (fourth l) *clock-increment-in-milliseconds*)
X              (* (float (/ (fourth l) (first l))) *clock-increment-in-milliseconds*)
X       )
X    )
X    (dolist (l (reverse *messaging-results*))
X      (format istream
X              "Operation Invocation~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X              (first l)
X              (second l)
X              (* (fourth l) *clock-increment-in-milliseconds*)
X              (* (float (/ (fourth l) (first l))) *clock-increment-in-milliseconds*)
X       )
X    )
X    (format istream "~|")
X
X
X    (format istream "~%~%~A~%~%" fromwho)
X    (format istream "~%~%All Times in msec~%~%")
X
X    (format istream "~1,8@T~1,8@T~1,8@TType Definition and Instance Creation~%~%")
X    (format istream
X            "Operation~1,8@TSlots~1,8@TParents~1,8@TIterations~1,8@TTotal Time~1,8@TTime per Call~%~%"
X    )
X    (dolist (l (reverse *define-type-results*))
X      (format istream
X              "Define Type~1,8@T~D~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X              (second l)
X              (third l)
X              (first l)
X              (* (fourth l) *clock-increment-in-milliseconds*)
X              (* (float (/ (fourth l) (first l))) *clock-increment-in-milliseconds*)
X       )
X    )
X
X    (dolist (l (reverse *creation-results*))
X      (format istream
X              "Create Instance~1,8@T~D~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X              (second l)
X              (third l)
X              (first l)
X              (* (fourth l) *clock-increment-in-milliseconds*)
X              (* (float (/ (fourth l) (first l))) *clock-increment-in-milliseconds*)
X       )
X    )
X
X    (format istream "~%~%~1,8@T~1,8@TOperation Creation and Invocation~%~%")
X    (format istream
X            "Operation~1,8@TIterations~1,8@TFunctions~1,8@TTotal Time~1,8@TTime per Call~%~%"
X    )
X    (dolist (l (reverse *define-method-results*))
X      (format istream
X              "Define Operation~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X              (first l)
X              (second l)
X              (* (third l) *clock-increment-in-milliseconds*)
X              (* (float (/ (third l) (first l))) *clock-increment-in-milliseconds*)
X       )
X    )
X
X    (dolist (l (reverse *messaging-results*))
X      (format istream
X              "Operation Invocation~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X              (first l)
X              (second l)
X              (* (third l) *clock-increment-in-milliseconds*)
X              (* (float (/ (third l) (first l))) *clock-increment-in-milliseconds*)
X       )
X    )
X
X    (format istream "~%~%~1,8@T~1,8@TInherited Operation Invocation~%~%")
X    (format istream
X            "Operation~1,8@TIterations~1,8@TParents~1,8@TTotal Time~1,8@TTime per Call~%~%"
X    )
X
X    (dolist (l (reverse *inherited-messaging-results*))
X      (format istream
X              "Operation Invocation~1,8@T~D~1,8@T~D~1,8@T~1,8@T~8,2F~1,8@T~8,2F~%"
X              (first l)
X              (second l)
X              (* (third l) *clock-increment-in-milliseconds*)
X              (* (float (/ (third l) (first l))) *clock-increment-in-milliseconds*)
X       )
X    )
X    (format istream "~|")
X  ) ;with-open-file
X
X  (setf *define-type-results* NIL)
X  (setf *creation-results* NIL)
X  (setf *define-method-results* NIL)
X  (setf *messaging-results* NIL)
X  (setf *inherited-messaging-results* NIL)
X
X) ;print-results
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(provide "co-profmacs")
X
END_OF_FILE
if test 20279 -ne `wc -c <'profmacs.l'`; then
    echo shar: \"'profmacs.l'\" unpacked with wrong size!
fi
# end of 'profmacs.l'
fi
echo shar: End of archive 5 \(of 13\).
cp /dev/null ark5isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 13 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--

Rich $alz            "Anger is an energy"
Cronus Project, BBN Labs    [e-mail]
Moderator, comp.sources.unix    [e-mail]